home *** CD-ROM | disk | FTP | other *** search
/ User's Choice Windows CD / User's Choice Windows CD (CMS Software)(1993).iso / windows5 / vbterm.zip / VT100.BAS < prev   
BASIC Source File  |  1991-08-31  |  17KB  |  632 lines

  1. '
  2. '   FILE    vt100.bas
  3. '
  4. '       This is the code to emulate a vt100 and interface to the windows API
  5. '
  6. '   Charles McGuinness [76701,11]
  7. '
  8. '
  9. Dim curx            As Integer
  10. Dim cury            As Integer
  11. Dim curpx           As Integer
  12. Dim curpy           As Integer
  13.  
  14. Dim InEscape        As Integer      ' Processing an escape seq?
  15. Dim EscString       As String       ' String so far
  16.  
  17. Dim CharHeight      As Integer
  18. Dim CharWidth       As Integer
  19.  
  20. Dim CurState        As Integer
  21.  
  22. Dim ttyhdc          As Integer
  23.  
  24. Declare Function BitBlt Lib "GDI" (ByVal hDestDC As Integer, ByVal x As Integer, ByVal y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hSrcDC As Integer, ByVal XSrc As Integer, ByVal YSrc As Integer, ByVal dwRop As Long) As Integer
  25.  
  26. '   Ternary raster operations
  27. Const SRCCOPY = &HCC0020        ' (DWORD) dest = source
  28. Const SRCPAINT = &HEE0086       ' (DWORD) dest = source OR dest
  29. Const SRCAND = &H8800C6         ' (DWORD) dest = source AND dest
  30. Const SRCINVERT = &H660046      ' (DWORD) dest = source XOR dest
  31. Const SRCERASE = &H440328       ' (DWORD) dest = source AND (NOT dest )
  32. Const NOTSRCCOPY = &H330008     ' (DWORD) dest = (NOT source)
  33. Const NOTSRCERASE = &H1100A6    ' (DWORD) dest = (NOT src) AND (NOT dest)
  34. Const MERGECOPY = &HC000CA      ' (DWORD) dest = (source AND pattern)
  35. Const MERGEPAINT = &HBB0226     ' (DWORD) dest = (NOT source) OR dest
  36. Const PATCOPY = &HF00021        ' (DWORD) dest = pattern
  37. Const PATPAINT = &HFB0A09       ' (DWORD) dest = DPSnoo
  38. Const PATINVERT = &H5A0049      ' (DWORD) dest = pattern XOR dest
  39. Const DSTINVERT = &H550009      ' (DWORD) dest = (NOT dest)
  40. Const BLACKNESS = &H42&         ' (DWORD) dest = BLACK
  41. Const WHITENESS = &HFF0062      ' (DWORD) dest = WHITE
  42.  
  43. '
  44. '   Calls to output text
  45. '
  46. Declare Function TextOut Lib "GDI" (ByVal hdc%, ByVal x%, ByVal y%, ByVal lpString$, ByVal nCount%) As Integer
  47.  
  48. '
  49. '   Set text to transparent or opaque
  50. '
  51. Declare Function SetBkMode Lib "GDI" (ByVal hdc%, ByVal nmode%) As Integer
  52.  
  53. Const TRANSPARENT = 1
  54. Const OPAQUE = 2
  55.  
  56. '
  57. '   Color management
  58. '
  59. Declare Function GetTextColor Lib "GDI" (ByVal hdc%) As Long
  60. Declare Function SetTextColor Lib "GDI" (ByVal hdc%, newcolor As Long) As Long
  61.  
  62. Declare Function GetBkColor Lib "GDI" (ByVal hdc%) As Long
  63. Declare Function SetBkColor Lib "GDI" (ByVal hdc%, newcolor As Long) As Long
  64.  
  65.  
  66.  
  67. Dim ScrImage(0 To 23) As String * 80
  68. ''' Removed to improve speed ''' Dim ScrAttr(0 to 23) As String * 80
  69. Dim Normal80 As String
  70. ''' Removed to improve speed ''' Dim CurAttr As String
  71.  
  72.  
  73. '
  74. '   Current Buffered Text
  75. '
  76.  
  77.     Dim outstr As String
  78.     Dim outx As Integer
  79.     Dim outlen As Integer
  80.  
  81. '
  82. '   Flag to indicate that we're ready to run
  83. '
  84.     Dim FlagInit As Integer
  85.  
  86. Sub term_init ()
  87.     curx = 0
  88.     cury = 0
  89.     curpx = 0
  90.     curpy = 0
  91.     InEscape = 0
  92.     CurState = 0
  93.     
  94.     outx = curpx
  95.     outstr = ""
  96.     outlen = 0
  97.  
  98.     CharHeight = tty.TextHeight("M")
  99.     CharWidth = tty.TextWidth("M")
  100.  
  101.     r% = SetBkMode(tty.hdc, OPAQUE)
  102.     disp_cursor
  103.  
  104.     ''' Removed to improve speed '''     Normal80 = String$(80, "0")
  105.  
  106.     For i% = 0 To 23
  107.         ScrImage(i%) = Space$(80)
  108.         ''' Removed to improve speed '''         ScrAttr(i%) = Normal80
  109.     Next i%
  110.  
  111.     ''' Removed to improve speed '''     CurAttr = "0"
  112.  
  113.     FlagInit = -1
  114. End Sub
  115.  
  116. Sub disp_cursor ()
  117.  
  118.     If CurState <> 0 Then Exit Sub
  119.  
  120.     sx% = curpx
  121.     sy% = curpy
  122.  
  123.     If tty.windowstate <> 1 Then
  124.         ttyhdc = tty.hdc
  125.         r% = BitBlt(ttyhdc, sx%, sy%, CharWidth, CharHeight, ttyhdc, sx%, sy%, DSTINVERT)
  126.     End If
  127.  
  128.     CurState = -1
  129.  
  130. End Sub
  131.  
  132. Sub compute_xy ()
  133.     curpx = curx * CharWidth
  134.     curpy = cury * CharHeight
  135. End Sub
  136.  
  137. Sub hide_cursor ()
  138.  
  139.     If CurState = 0 Then Exit Sub
  140.  
  141.     sx% = curpx
  142.     sy% = curpy
  143.  
  144.  
  145.     If tty.windowstate <> 1 Then
  146.         ttyhdc = tty.hdc
  147.         r% = BitBlt(ttyhdc, sx%, sy%, CharWidth, CharHeight, ttyhdc, sx%, sy%, DSTINVERT)
  148.     End If
  149.  
  150.     CurState = 0
  151. End Sub
  152.  
  153. Sub scroll_up ()
  154.     Dim wid As Integer
  155.     Dim High As Integer
  156.     Dim cHigh As Integer
  157.  
  158.     wid = tty.width
  159.     cHigh = CharHeight
  160.     High = 23 * cHigh
  161.  
  162.     If (High > tty.ScaleHeight) Then
  163.         High = tty.ScaleHeight
  164.         End If
  165.  
  166.     If tty.windowstate <> 1 Then
  167.         ttyhdc = tty.hdc
  168.         r% = BitBlt(ttyhdc, 0, 0, wid, High, ttyhdc, 0, cHigh, SRCCOPY)
  169.         r% = BitBlt(ttyhdc, 0, High, wid, cHigh, ttyhdc, 0, High, WHITENESS)
  170.     End If
  171.  
  172.     For i% = 0 To 22
  173.         ScrImage(i%) = ScrImage(i% + 1)
  174. ''' Removed to improve speed '''         ScrAttr(i%) = ScrAttr(i% + 1)
  175.     Next i%
  176.  
  177.     ScrImage(23) = Space$(80)
  178. ''' Removed to improve speed '''     ScrAttr(24) = Normal80
  179.  
  180. End Sub
  181.  
  182. Sub term_put (buf As String, cnt As Integer)
  183.  
  184.     Dim i As Integer
  185.     Dim ch As Integer
  186.  
  187.     If (CurState <> 0) Then
  188.         Call hide_cursor
  189.     End If
  190.  
  191.     i = 1
  192.  
  193.     If (InEscape = 0) Then
  194.         GoTo CharLoop
  195.     End If
  196.  
  197. EscapeLoop:
  198.  
  199.     Do
  200.         Call AddEscape(Asc(Mid$(buf, i, 1)))
  201.         outx = curpx
  202.         i = i + 1
  203.         If (InEscape = 0) And (i <= cnt) Then
  204.             GoTo CharLoop
  205.         End If
  206.     Loop While i <= cnt
  207.  
  208.     Exit Sub
  209.  
  210. CharLoop:
  211.  
  212.     Do
  213.         C$ = Mid$(buf, i, 1)
  214.         ch = Asc(C$)
  215.  
  216.         If ch > 31 Then
  217.             outstr = outstr + C$
  218.             outlen = outlen + 1
  219.             Mid$(ScrImage(cury), curx + 1, 1) = C$
  220.             ''' Removed to improve speed ''' Mid$(ScrAttr(cury), curx + 1, 1) = CurAttr
  221.             curx = curx + 1
  222.             curpx = curpx + CharWidth
  223.  
  224.             If (curx = 80) Then
  225.                 Call WriteText
  226.                 Call term_put(Chr$(13) + Chr$(10), 2)
  227.             End If
  228.  
  229.         Else
  230.                 Select Case ch
  231.  
  232.                 Case 13     ' Return
  233.                     If (outlen <> 0) Then Call WriteText
  234.  
  235.                     curx = 0
  236.                     curpx = 0
  237.                     outx = curpx
  238.  
  239.                 Case 10     ' Line Feed
  240.                     If (outlen <> 0) Then Call WriteText
  241.                 
  242.                     cury = cury + 1
  243.                     If (cury = 24) Then
  244.                         Call scroll_up
  245.                         cury = 23
  246.                     Else
  247.                         curpy = curpy + CharHeight
  248.                     End If
  249.  
  250.                 Case 8  ' Backspace
  251.                     If (outlen <> 0) Then Call WriteText
  252.                 
  253.                     curx = curx - 1
  254.                     If curx < 0 Then
  255.                         curx = 0
  256.                     Else
  257.                         curpx = curpx - CharWidth
  258.                         outx = curpx
  259.                     End If
  260.  
  261.                 Case 9  ' TAB (non-destructive)
  262.  
  263.                     If (curx < 72) Then
  264.                         If (outlen <> 0) Then
  265.                             Call WriteText
  266.                         End If
  267.                         curx = curx + (8 - (curx Mod 8))
  268.                         curpx = curx * CharWidth
  269.                         outx = curpx
  270.                     End If
  271.  
  272.                 ' BEL
  273.                 Case 7
  274.                     Beep
  275.  
  276.                 ' Escape
  277.                 Case 27
  278.                     If (outlen <> 0) Then WriteText
  279.                     If (FlagMonitor <> 0) Then
  280.                         Call term_put("ESC", 3)
  281.                     Else
  282.                         Call StartEscape
  283.                         i = i + 1
  284.                         If (i <= cnt) Then GoTo EscapeLoop
  285.                     End If
  286.                 End Select
  287.         End If
  288.  
  289.         i = i + 1
  290.     Loop While i <= cnt
  291.  
  292. End Sub
  293.  
  294. Sub StartEscape ()
  295.     InEscape = -1
  296.     EscString = ""
  297. End Sub
  298.  
  299. Sub AddEscape (ch As Integer)
  300.  
  301.     Dim C As String
  302.     Dim l As Long
  303.  
  304.  
  305.     C = Chr$(ch)
  306.  
  307.     If EscString = "" And C <> "[" Then
  308.         InEscape = 0
  309.         Exit Sub
  310.         End If
  311.  
  312.     EscString = EscString + C
  313.  
  314.     If (LCase$(C) = UCase$(C)) Then
  315.         Rem Not a letter ...
  316.  
  317.         If Len(EscString) > 16 Then InEscape = 0
  318.         Exit Sub
  319.         End If
  320.  
  321.     Select Case C
  322.  
  323.     Case "H", "f"
  324.         EscString = Mid$(EscString, 2)
  325.         cury = Val(PopArg(EscString)) - 1
  326.         If (cury < 0) Then cury = 0
  327.         curx = Val(EscString) - 1
  328.         If (curx < 0) Then curx = 0
  329.         compute_xy
  330.  
  331.     Case "A"
  332.         EscString = Mid$(EscString, 2)
  333.         If (isdigit(EscString)) Then
  334.             cury = cury - Val(PopArg(EscString))
  335.         Else
  336.             cury = cury - 1
  337.         End If
  338.         If (cury < 0) Then cury = 0
  339.         Call compute_xy
  340.  
  341.     Case "B"
  342.         EscString = Mid$(EscString, 2)
  343.         If (isdigit(EscString) <> 0) Then
  344.             cury = cury + Val(PopArg(EscString))
  345.         Else
  346.             cury = cury + 1
  347.         End If
  348.         If (cury > 23) Then cury = 23
  349.         Call compute_xy
  350.  
  351.     Case "C"
  352.         EscString = Mid$(EscString, 2)
  353.         If (isdigit(EscString)) Then
  354.             curx = curx + Val(PopArg(EscString))
  355.         Else
  356.             curx = curx + 1
  357.         End If
  358.         If (curx > 79) Then cury = 79
  359.         Call compute_xy
  360.  
  361.     Case "D"
  362.         EscString = Mid$(EscString, 2)
  363.         If (isdigit(EscString)) Then
  364.             curx = curx - Val(PopArg(EscString))
  365.         Else
  366.             curx = curx - 1
  367.         End If
  368.         If (curx < 0) Then cury = 0
  369.         Call compute_xy
  370.  
  371.  
  372.     Case "K"
  373.         Select Case Val(Mid$(EscString, 2))
  374.         Case 0
  375.             Call erase_eol
  376.         Case 1
  377.             Call erase_bol
  378.         Case 2
  379.             Call erase_line
  380.         End Select
  381.  
  382.     Case "J"
  383.         Select Case Val(Mid$(EscString, 2))
  384.         Case 0
  385.             Call erase_eos
  386.         Case 1
  387.             Call erase_bos
  388.         Case 2
  389.             Call erase_screen
  390.         End Select
  391.  
  392. ''' Removed to improve speed '''     Case "m"
  393. ''' Removed to improve speed '''         EscString = Mid$(EscString, 2)
  394. ''' Removed to improve speed '''         Do
  395. ''' Removed to improve speed '''             Call SetAttr(PopArg(EscString))
  396. ''' Removed to improve speed '''         Loop While EscString <> ""
  397.     End Select
  398.  
  399.     InEscape = 0
  400.     EscString = ""
  401.  
  402. End Sub
  403.  
  404. Function PopArg (s As String) As String
  405. '
  406. '   PopArg takes the next argument (digits up to a ;) and
  407. '   returns it.  It also removes the arg and the ; from
  408. '   the "s"
  409.  
  410.     If InStr(s, ";") = 0 Then
  411.         PopArg = s
  412.         s = ""
  413.         Exit Function
  414.     End If
  415.  
  416.     i% = InStr(s, ";")
  417.     PopArg = Left$(s, i% - 1)
  418.     s = Mid$(s$, i% + 1)
  419. End Function
  420.  
  421. Sub erase_bos ()
  422. '
  423. '   Erase from Beginning of Screen
  424. '
  425.     Dim wid As Integer
  426.     Dim High As Integer
  427.     Dim cHigh As Integer
  428.  
  429.     Call erase_bol
  430.  
  431.     If (cury = 0) Then Exit Sub
  432.  
  433.     wid = tty.width
  434.     cHigh = CharHeight
  435.     High = (cury - 1) * cHigh
  436.  
  437.     If tty.windowstate <> 1 Then
  438.         ttyhdc = tty.hdc
  439.         r% = BitBlt(ttyhdc, 0, 0, wid, High, ttyhdc, 0, 0, WHITENESS)
  440.     End If
  441.     For y% = 0 To cury - 1
  442.         ScrImage(y%) = Space$(80)
  443. ''' Removed to improve speed '''         ScrAttr(y%) = Normal80
  444.         Next y%
  445.  
  446. End Sub
  447.  
  448. Sub erase_line ()
  449. '   Erase Line
  450.  
  451.     Dim wid As Integer
  452.     Dim High As Integer
  453.     Dim cHigh As Integer
  454.     Dim StartX As Integer
  455.  
  456.     wid = tty.width
  457.     cHigh = tty.TextHeight("M")
  458.     High = cury * cHigh
  459.  
  460.     If tty.windowstate <> 1 Then
  461.         r% = BitBlt(tty.hdc, 0, High, wid, cHigh, tty.hdc, 0, High, WHITENESS)
  462.     End If
  463.  
  464.     ScrImage(cury) = Space$(80)
  465. ''' Removed to improve speed '''     ScrAttr(cury) = Normal80
  466. End Sub
  467.  
  468. Sub erase_eos ()
  469. '
  470. '   Erase to end of screen
  471. '
  472.     Dim wid As Integer
  473.     Dim High As Integer
  474.     Dim cHigh As Integer
  475.     Dim StartY As Integer
  476.  
  477.     Call erase_eol
  478.  
  479.     If (cury = 23) Then Exit Sub
  480.  
  481.     wid = tty.ScaleWidth
  482.     cHigh = tty.TextHeight("M")
  483.     StartY = (cury + 1) * cHigh
  484.     High = 24 * cHigh - StartY
  485.  
  486.  
  487.     If tty.windowstate <> 1 Then
  488.         r% = BitBlt(tty.hdc, 0, StartY, wid, High, tty.hdc, 0, StartY, WHITENESS)
  489.     End If
  490.  
  491.     For y% = cury + 1 To 23
  492.         ScrImage(y%) = Space$(80)
  493. ''' Removed to improve speed '''         ScrAttr(y%) = Normal80
  494.     Next y%
  495. End Sub
  496.  
  497. Sub erase_eol ()
  498. '
  499. '   Erase to End of Line
  500. '
  501.     Dim wid As Integer
  502.     Dim High As Integer
  503.     Dim cHigh As Integer
  504.     Dim StartX As Integer
  505.  
  506.     wid = tty.width
  507.     cHigh = CharHeight
  508.     High = curpy
  509.     StartX = curpx
  510.  
  511.     If tty.windowstate <> 1 Then
  512.         r% = BitBlt(tty.hdc, StartX, High, wid - StartX, cHigh, tty.hdc, StartX, High, WHITENESS)
  513.     End If
  514.  
  515.     Mid$(ScrImage(cury), curx + 1, 80 - curx) = Space$(80 - curx)
  516. ''' Removed to improve speed '''     Mid$(ScrAttr(cury), curx + 1, 80 - curx) = String$(80 - curx, "0")
  517.  
  518. End Sub
  519.  
  520. Sub erase_bol ()
  521. '
  522. '   Erase From Beginning of Line
  523. '
  524.     Dim wid As Integer
  525.     Dim High As Integer
  526.     Dim cHigh As Integer
  527.  
  528.  
  529.     cHigh = CharHeight
  530.     High = curpy
  531.     wid = curpx
  532.  
  533.     If tty.windowstate <> 1 Then
  534.         ttyhdc = tty.hdc
  535.         r% = BitBlt(ttyhdc, 0, High, wid, cHigh, ttyhdc, 0, High, WHITENESS)
  536.     End If
  537.  
  538.     Mid$(ScrImage(cury), 1, curx + 1) = Space$(curx + 1)
  539. ''' Removed to improve speed '''     Mid$(ScrAttr(cury), 1, curx + 1) = String$(curx + 1, "0")
  540.  
  541. End Sub
  542.  
  543. Sub erase_screen ()
  544.     tty.Cls
  545.     For y% = 0 To 23
  546.         ScrImage(y%) = Space$(80)
  547. ''' Removed to improve speed '''         ScrAttr(y%) = Normal80
  548.         Next y%
  549. End Sub
  550.  
  551. Sub WriteText ()
  552.     r% = TextOut(tty.hdc, outx, curpy, outstr, outlen)
  553.     outstr = ""
  554.     outlen = 0
  555.     outx = curpx
  556. End Sub
  557.  
  558. Sub RedrawScreen ()
  559.     Dim oldcur As Integer
  560.     Dim oldattr As String
  561.  
  562.  
  563.     If FlagInit <> -1 Then Exit Sub
  564.  
  565.     If tty.windowstate = 1 Then Exit Sub
  566.  
  567.     oldcur = CurState
  568.  
  569. ''' Removed to improve speed '''    oldattr = CurAttr
  570.  
  571.     Call hide_cursor
  572. ''' Removed to improve speed '''    Call SetAttr("0")
  573.  
  574.     ttyhdc = tty.hdc
  575.     ty% = 0
  576.     For y% = 0 To 23
  577. ''' Removed to improve speed '''         If (ScrAttr(y%) = Normal80) Then
  578.             r% = TextOut(ttyhdc, 0, ty%, ScrImage(y%), 80)
  579. ''' Removed to improve speed '''         Else
  580. ''' Removed to improve speed '''             tx% = 0
  581. ''' Removed to improve speed '''             For x% = 1 To 80
  582. ''' Removed to improve speed '''                 If (Mid$(ScrAttr(y%), x%, 1) <> CurAttr) Then
  583. ''' Removed to improve speed '''                     Call SetAttr(Mid$(ScrAttr(y%), x%, 1))
  584. ''' Removed to improve speed '''                     End If
  585. ''' Removed to improve speed '''                 r% = TextOut(tty.hdc, tx%, ty%, Mid$(ScrImage(y%), x%, 1), 1)
  586. ''' Removed to improve speed '''                 tx% = tx% + charwidth
  587. ''' Removed to improve speed '''                 Next x%
  588. ''' Removed to improve speed '''         End If
  589.         ty% = ty% + CharHeight
  590.         ' r% = DoEvents()
  591.     Next y%
  592.  
  593. ''' Removed to improve speed '''     Call SetAttr(oldattr)
  594.     If oldcur <> 0 Then Call disp_cursor
  595. End Sub
  596.  
  597. Sub SetAttr (ch As String)
  598.  
  599. ''' Removed to improve speed '''    Select Case Val(ch)
  600. ''' Removed to improve speed '''            Case 0
  601. ''' Removed to improve speed '''                tty.fontbold = 0
  602. ''' Removed to improve speed '''                tty.fontunderline = 0
  603. ''' Removed to improve speed '''                tty.fontitalic = 0
  604. ''' Removed to improve speed '''                tty.forecolor = QBColor(0)
  605. ''' Removed to improve speed '''                CurAttr = "0"
  606. ''' Removed to improve speed '''            Case 1
  607. ''' Removed to improve speed '''                tty.fontbold = -1
  608. ''' Removed to improve speed '''                CurAttr = "1"
  609. ''' Removed to improve speed '''            Case 5
  610. ''' Removed to improve speed '''                tty.fontitalic = -1
  611. ''' Removed to improve speed '''                CurAttr = "5"
  612. ''' Removed to improve speed '''            Case 4
  613. ''' Removed to improve speed '''                tty.fontunderline = -1
  614. ''' Removed to improve speed '''                CurAttr = "4"
  615. ''' Removed to improve speed '''            Case 7
  616. ''' Removed to improve speed '''                tty.forecolor = QBColor(8)
  617. ''' Removed to improve speed '''                CurAttr = "7"
  618. ''' Removed to improve speed '''    End Select
  619.  
  620. End Sub
  621.  
  622. Function isdigit (s$)
  623.     If (Left$(s$, 1) < "0") Then
  624.         isdigit = 0
  625.     ElseIf (Left$(s$, 1) > "9") Then
  626.         isdigit = 0
  627.     Else
  628.         isdigit = 1
  629.     End If
  630. End Function
  631.  
  632.